home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / loop.lisp < prev    next >
Encoding:
Text File  |  1991-11-06  |  8.6 KB  |  238 lines
  1. ;;; -*- Package: C; Log: C.Log -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: loop.lisp,v 1.2 91/02/20 14:58:33 ram Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;;    Stuff to annotate the flow graph with information about the loops in it.
  15. ;;;
  16. ;;; Written by Rob MacLachlan
  17. ;;;
  18. (in-package 'c)
  19.  
  20. ;;; Find-Dominators  --  Internal
  21. ;;;
  22. ;;;    Find the set of blocks that dominates each block in Component.  We
  23. ;;; assume that the Dominators for each block is initially NIL, which serves to
  24. ;;; represent the set of all blocks.  If a block is not reachable from an entry
  25. ;;; point, then its dominators will still be NIL when we are done.
  26. ;;;
  27. (defun find-dominators (component)
  28.   (let ((head (loop-head component))
  29.     changed)
  30.     (let ((set (make-sset)))
  31.       (sset-adjoin head set)
  32.       (setf (block-dominators head) set))
  33.     (loop
  34.      (setq changed nil)
  35.      (do-blocks (block component :tail)
  36.        (let ((dom (block-dominators block)))
  37.      (when dom (sset-delete block dom))
  38.      (dolist (pred (block-pred block))
  39.        (let ((pdom (block-dominators pred)))
  40.          (when pdom
  41.            (if dom
  42.            (when (sset-intersection dom pdom)
  43.              (setq changed t))
  44.            (setq dom (copy-sset pdom) changed t)))))
  45.      
  46.      (setf (block-dominators block) dom)
  47.      (when dom (sset-adjoin block dom))))
  48.      (unless changed (return)))))
  49.  
  50.  
  51. ;;; Dominates-P  --  Internal
  52. ;;;
  53. ;;;    Return true if Block1 dominates Block2, false otherwise.
  54. ;;;
  55. (proclaim '(function dominates-p (block block) boolean))
  56. (defun dominates-p (block1 block2)
  57.   (let ((set (block-dominators block2)))
  58.     (if set
  59.     (sset-member block1 set)
  60.     t)))
  61.  
  62. ;;; Loop-Analyze  --  Interface
  63. ;;;
  64. ;;;    Set up the Loop structures which describe the loops in the flow graph
  65. ;;; for Component.  We NIL out any existing loop information, and then scan
  66. ;;; through the blocks looking for blocks which are the destination of a
  67. ;;; retreating edge: an edge that goes backward in the DFO.  We then create
  68. ;;; Loop structures to describe the loops that have those blocks as their
  69. ;;; heads.  If find the head of a strange loop, then we do some graph walking
  70. ;;; to find the other segments in the strange loop.  After we have found the
  71. ;;; loop structure, we walk it to initialize the block lists.
  72. ;;;
  73. (proclaim '(function loop-analyze (component) void))
  74. (defun loop-analyze (component)
  75.   (do-blocks (block component :both)
  76.     (setf (block-loop block) nil))
  77.   (setf (loop-inferiors component) ())
  78.   (setf (loop-blocks component) nil)
  79.  
  80.   (do-blocks (block component)
  81.     (let ((number (block-number block)))
  82.       (dolist (pred (block-pred block))
  83.     (when (<= (block-number pred) number)
  84.       (when (note-loop-head block component)
  85.         (clear-flags component)
  86.         (setf (block-flag block) :good)
  87.         (dolist (succ (block-succ block))
  88.           (find-strange-loop-blocks succ block))
  89.         (find-strange-loop-segments block component))
  90.       (return)))))
  91.  
  92.   (find-loop-blocks component))
  93.  
  94.  
  95. ;;; Find-Loop-Blocks  --  Internal
  96. ;;;
  97. ;;;    This function initializes the block lists for Loop and the loops nested
  98. ;;; within it.  We recursively descend into the loop nesting and place the
  99. ;;; blocks in the appropriate loop on the way up.  When we are done, we scan
  100. ;;; the blocks looking for exits.  An exit is always a block that has a
  101. ;;; successor which doesn't have a Loop assigned yet, since the target of the
  102. ;;; exit must be in a superior loop.
  103. ;;;
  104. ;;;    We find the blocks by doing a forward walk from the head of the loop and
  105. ;;; from any exits of nested loops.  The walks from inferior loop exits are
  106. ;;; necessary because the walks from the head terminate when they encounter a
  107. ;;; block in an inferior loop.
  108. ;;;
  109. (proclaim '(function find-loop-blocks (loop) void))
  110. (defun find-loop-blocks (loop)
  111.   (dolist (sub-loop (loop-inferiors loop))
  112.     (find-loop-blocks sub-loop))
  113.  
  114.   (find-blocks-from-here (loop-head loop) loop)
  115.   (dolist (sub-loop (loop-inferiors loop))
  116.     (dolist (exit (loop-exits sub-loop))
  117.       (dolist (succ (block-succ exit))
  118.     (find-blocks-from-here succ loop))))
  119.   
  120.   (collect ((exits))
  121.     (dolist (sub-loop (loop-inferiors loop))
  122.       (dolist (exit (loop-exits sub-loop))
  123.     (dolist (succ (block-succ exit))
  124.       (unless (block-loop succ)
  125.         (exits exit)
  126.         (return)))))
  127.     
  128.     (do ((block (loop-blocks loop) (block-loop-next block)))
  129.     ((null block))
  130.       (dolist (succ (block-succ block))
  131.     (unless (block-loop succ)
  132.       (exits block)
  133.       (return))))
  134.     
  135.     (setf (loop-exits loop) (exits))))
  136.  
  137.  
  138. ;;; Find-Blocks-From-Here  --  Internal
  139. ;;;
  140. ;;;    This function does a graph walk to find the blocks directly within Loop
  141. ;;; that can be reached by a forward walk from Block.  If Block is already
  142. ;;; in a loop or is not dominated by the Loop-Head, then we return.  Otherwise,
  143. ;;; we add the block to the Blocks for Loop and recurse on its successors.
  144. ;;;
  145. (proclaim '(function find-blocks-from-here (block loop) void))
  146. (defun find-blocks-from-here (block loop)
  147.   (when (and (not (block-loop block))
  148.          (dominates-p (loop-head loop) block))
  149.     (setf (block-loop block) loop)
  150.     (shiftf (block-loop-next block) (loop-blocks loop) block)
  151.     (dolist (succ (block-succ block))
  152.       (find-blocks-from-here succ loop))))
  153.  
  154.  
  155. ;;; Note-Loop-Head  --  Internal
  156. ;;;
  157. ;;;    Create a loop structure to describe the loop headed by the block Head.
  158. ;;; If there is one already, just return.  If some retreating edge into the
  159. ;;; head is from a block which isn't dominated by the head, then we have the
  160. ;;; head of a strange loop segment.  We return true if Head is part of a newly
  161. ;;; discovered strange loop.
  162. ;;;
  163. (proclaim '(function note-loop-head (block component) void))
  164. (defun note-loop-head (head component)
  165.   (let ((superior (find-superior head component)))
  166.     (unless (eq (loop-head superior) head)
  167.       (let ((result (make-loop :head head  :component component  :kind :natural
  168.                    :superior superior  :depth (1+ (loop-depth superior))))
  169.         (number (block-number head)))
  170.     (push result (loop-inferiors superior))
  171.     (dolist (pred (block-pred head))
  172.       (when (<= (block-number pred) number)
  173.         (if (dominates-p head pred)
  174.         (push pred (loop-tail result))
  175.         (setf (loop-kind result) :strange))))
  176.     
  177.     (eq (loop-kind result) :strange)))))
  178.  
  179.  
  180. ;;; Find-Superior  --  Internal
  181. ;;;
  182. ;;;    Find the loop which would be the superior of a loop headed by Head.  If
  183. ;;; there is already a loop with that head, then return that loop.
  184. ;;;
  185. (proclaim '(function find-superior (block loop) loop))
  186. (defun find-superior (head loop)
  187.   (if (eq (loop-head loop) head)
  188.       loop
  189.       (dolist (inferior (loop-inferiors loop) loop)
  190.     (when (dominates-p (loop-head inferior) head)
  191.       (return (find-superior head inferior))))))
  192.  
  193.  
  194. ;;; Find-Strange-Loop-Blocks  --  Internal
  195. ;;;
  196. ;;;    Do a graph walk to find the blocks in the strange loop which Head is in.
  197. ;;; Block is the block we are currently at and Component is the component we
  198. ;;; are in.  We do a walk forward from block, using only edges which are not
  199. ;;; back edges.  We return true if there is a path from Block to Head, false
  200. ;;; otherwise.  If the Block-Flag is true then we return.  We use two non-null
  201. ;;; values of Flag to indicate whether a path from the Block back to Head was
  202. ;;; found.
  203. ;;;
  204. (proclaim '(function find-strange-loop-blocks (block block) boolean))
  205. (defun find-strange-loop-blocks (block head)
  206.   (let ((flag (block-flag block)))
  207.     (cond (flag
  208.        (if (eq flag :good)
  209.            t
  210.            nil))
  211.       (t
  212.        (setf (block-flag block) :bad)
  213.        (unless (dominates-p block head)
  214.          (dolist (succ (block-succ block))
  215.            (when (find-strange-loop-blocks succ head)
  216.          (setf (block-flag block) :good))))
  217.        
  218.        (eq (block-flag block) :good)))))
  219.  
  220.  
  221. ;;; Find-Strange-Loop-Segments  --  Internal
  222. ;;;
  223. ;;;    Do a graph walk to find the segments in the strange loop that has Block
  224. ;;; in it.  We walk forward, looking only at blocks in the loop (flagged as
  225. ;;; :Good.)  Each block in the loop that has predecessors outside of the
  226. ;;; loop is the head of a segment.  We enter the Loop structures in Component.
  227. ;;;
  228. (proclaim '(function find-strange-loop-segments (block component) void))
  229. (defun find-strange-loop-segments (block component)
  230.   (when (eq (block-flag block) :good)
  231.     (setf (block-flag block) :done)
  232.     (unless (every #'(lambda (x) (member (block-flag x) '(:good :done)))
  233.            (block-pred block))
  234.       (note-loop-head block component))
  235.  
  236.     (dolist (succ (block-succ block))
  237.       (find-strange-loop-segments succ component))))
  238.